home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
090
/
byte0487.arc
/
TELLO.ARC
/
TIMING.LSP
< prev
next >
Wrap
Text File
|
1986-12-22
|
4KB
|
118 lines
; timimg routines
(defconstant internal-time-units-per-second 100)
(defun get-internal-run-time ()
(multiple-value-bind (ignore1 ignore2 ignore3 cx dx)
(sys:%sysint #x21 #x2c00 0 0 0)
(+ (* (lsh cx -8) 60 60 100)
(* (logand cx #xFF) 60 100)
(* (lsh dx -8) 100)
(logand dx #xFF))))
(defun timed-duration (fn)
(let ((start-run (get-internal-run-time)))
(funcall fn)
(let ((end-run (get-internal-run-time)))
(float (/ (- end-run start-run) internal-time-units-per-second)))))
(defparameter *minimum-tests* 1)
(defparameter *minimum-duration* 10.0)
(defun multiple-timed-duration (fn)
(let* ((total-run-time (timed-duration fn))
(repeats (max *minimum-tests*
(ceiling *minimum-duration*
(if (zerop total-run-time) 1
total-run-time)))))
(do ((count repeats (- count 1)))
((< count 2) (values total-run-time repeats))
(incf total-run-time (timed-duration fn)))))
(defvar *all-timers* nil)
(defvar *bad-timers* '(tak boyer))
(defmacro define-timer (name documentation &body body)
`(progn (pushnew ',name *all-timers*)
(setf (get ',name 'timing-function)
,(if (and (= (length body) 1) (= (length (first body)) 1))
(list 'quote (first (first body)))
`#'(lambda () . ,body)))
(setf (get ',name 'timing-documentation) ,documentation)))
(defun run-tests (&optional file)
(if (null file) (run-tests1 't)
(with-open-file (stream file :direction :output) (run-tests1 stream))))
(defun run-tests1 (stream)
(describe-implementation stream)
(do ((tests *all-timers* (cdr tests))) ((null tests) '*)
(cond ((member (first tests) *bad-timers*)
(format stream "~&Run of ~A punted due to stack group reset.~%"
(get (first tests) 'timing-documentation)))
(t (sys::gc)
(multiple-value-bind (answer error?)
(ignore-errors (run-one (first tests) stream))
(if error? (format stream "~% ERROR: ~A~%" error?)))))))
(defun run-one (name &optional (stream *terminal-io*))
(unless (get name 'timing-documentation)
(error "~&There's no such benchmark as ~S.~%" name))
(format stream "~&Running ~A . . ." (get name 'timing-documentation))
(multiple-value-bind (time n-runs)
(multiple-timed-duration (get name 'timing-function))
(format stream "~% time: ~D seconds (based on ~D call"
(/ time n-runs) n-runs)
(unless (= n-runs 1) (write-char #\s stream))
(format stream ")~%" time n-runs)))
(defun describe-implementation (&optional (stream *standard-output*))
(format stream "~&Lisp Type: ~A" (lisp-implementation-type))
(format stream "~&Lisp Version: ~A" (lisp-implementation-version))
#+:Large-Memory
(format stream "~&Machine Type: IBM-PC/AT")
#-:Large-Memory
(format stream "~&Machine Type: IBM-PC/XT")
(format stream "~&Features: ~A" (car *features*))
(if (cdr *features*) (format stream ", "))
(do ((features (cdr *features*) (cdr features))
(offset (+ 17 (length (string (car *features*))))))
((null features))
(let* ((feature (string (car features))) (lth (length feature)))
(cond ((> (setq offset (+ offset 2 lth)) 76)
(setq offset (+ 15 lth))
(format stream "~& ~A" feature))
(t (format stream "~A" feature)))
(when (cdr features)
(setq offset (+ offset 2))
(format stream ", "))))
(format stream "~%~%"))
(defvar *benchmark-files*
'("DESTRUCT"
"IO"
"FRPOLY"
"TRIANG"
;"PUZZLE"
;"FFT"
"DIV"
"DERIV"
"TRAVERSE"
"BROWSE"
"BOYER"
"TAK"
))
(defmacro qa-attempt (&body stuff) (list 'quote stuff))
(defun benchmark-file (file) (merge-pathnames "C:>GCLISP2>" file))
(defun load-benchmark-files ()
(mapc #'(lambda (file) (load (benchmark-file file))) *benchmark-files*))
(defun compile-benchmark-files (&optional load?)
(mapc #'(lambda (file) (compile-file (benchmark-file file) :load load?))
*benchmark-files*))